home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / scm / wb1a1.lha / wb / defs.scm < prev    next >
Encoding:
Text File  |  1993-06-29  |  8.9 KB  |  231 lines
  1. ; Wb-tree File Based Associative String Data Base System.
  2. ; Copyright (c) 1991, 1992, 1993 Holland Mark Martin
  3. ;
  4. ;Permission to use, copy, modify, and distribute this software and its
  5. ;documentation for educational, research, and non-profit purposes and
  6. ;without fee is hereby granted, provided that the above copyright
  7. ;notice appear in all copies and that both that copyright notice and
  8. ;this permission notice appear in supporting documentation, and that
  9. ;the name of Holland Mark Martin not be used in advertising or
  10. ;publicity pertaining to distribution of the software without specific,
  11. ;written prior consent in each case.  Permission to incorporate this
  12. ;software into commercial products can be obtained from Jonathan
  13. ;Finger, Holland Mark Martin, 174 Middlesex Turnpike, Burlington, MA,
  14. ;01803-4467, USA.  Holland Mark Martin makes no representations about
  15. ;the suitability or correctness of this software for any purpose.  It
  16. ;is provided "as is" without express or implied warranty.  Holland Mark
  17. ;Martin is under no obligation to provide any services, by way of
  18. ;maintenance, update, or otherwise.
  19.  
  20.  
  21.         ;minimum is 1
  22. (define NUM-SEGS 10)
  23.  
  24.         ;minumum FLC-LEN is 10
  25.         ;This coresponds to 2 times the maximum number of
  26.         ;blocks which would ever be needed for a FREELIST split.
  27. (define FLC-LEN 20)
  28.  
  29.         ;amount to increase the ENT-TAB by when allocating buffers.
  30. (define ENT-TAB-INC 512)
  31.  
  32. ;;;; ERROR Return Codes
  33.  
  34. (define SUCCESS 0)            ; successful execution
  35. (define NOTPRES -1)            ; successful execution, no data present or no change made
  36. (define TERMINATED -2)            ; failure, no damage, caller can retry operation
  37. (define RETRYERR -10)            ; failure, no damage, caller can retry operation
  38. (define ARGERR -15)            ; failure, no damage, call was in error
  39. (define NOROOM -20)            ; failure, no damage, out of room in file
  40. (define TYPERR -30)            ; failure, file or object was not of correct type
  41. (define IOERR -40)            ; i/o error, DB may be damaged
  42. (define STRANGERR -45)            ; internal error, DB may be damaged
  43. (define UNKERR -90)            ; placeholder code
  44. (define MAXERR -100)
  45.  
  46. ;; return error code if a valid error code (-1..MAXERR) else false (0)
  47. (define (err? x)
  48.   (and (number? x) (negative? x) (>= x MAXERR) x))
  49.  
  50. (define (realerr? x)
  51.   (and (number? x) (<= x RETRYERR) (>= x MAXERR) x))
  52.  
  53. (define (success? x)
  54.   (not (err? x)))
  55.  
  56. ;;;; BLK parameters
  57.  
  58. ;;; The IDs are 4 byte numbers identifying this block, the root of
  59. ;;; this tree, and the next in the chain.
  60. (define BLK-ID-POS 0)
  61. (define BLK-TOP-ID-POS 4)
  62. (define BLK-NXT-ID-POS 8)
  63. (define BLK-TIME-POS 12)
  64. ;;; blk-end-pos is position (stored in 2 bytes) of first free byte
  65. (define BLK-END-POS 16)
  66. (define BLK-LEVEL-POS 18)
  67. (define BLK-TYP-POS 19)
  68. (define BLK-DATA-START 20)
  69.  
  70. (define (BLK-ID blk) (str2long blk BLK-ID-POS))
  71. (define (BLK-TOP-ID blk) (str2long blk BLK-TOP-ID-POS))
  72. (define (BLK-NXT-ID blk) (str2long blk BLK-NXT-ID-POS))
  73. (define (BLK-TIME blk) (str2long blk BLK-TIME-POS))
  74. (define (BLK-END blk) (str2short blk BLK-END-POS))
  75. (define (BLK-LEVEL b) (char->integer (string-ref b BLK-LEVEL-POS)))
  76. (define (BLK-TYP b) (string-ref b BLK-TYP-POS))
  77. (define (BLK-TYP? b typ) (char=? (string-ref b BLK-TYP-POS) typ))
  78.  
  79. (define (BLK-SET-ID! blk id) (long2str! blk BLK-ID-POS id))
  80. (define (BLK-SET-TOP-ID! blk id) (long2str! blk BLK-TOP-ID-POS id))
  81. (define (BLK-SET-NXT-ID! blk id) (long2str! blk BLK-NXT-ID-POS id))
  82. (define (BLK-SET-TIME! blk tim) (long2str! blk BLK-TIME-POS tim))
  83. (define (BLK-SET-END! blk pos) (short2str! blk BLK-END-POS pos))
  84. (define (BLK-SET-LEVEL! b level)
  85.   (string-set! b BLK-LEVEL-POS (integer->char level)))
  86. (define (BLK-SET-TYP! b typ) (string-set! b BLK-TYP-POS typ))
  87.  
  88. (define LEAF (char->integer #\0))
  89.  
  90. (define DIR-TYP #\D)
  91. (define IND-TYP #\T)
  92. (define SEQ-TYP #\S)
  93. (define FRL-TYP #\F)
  94.  
  95. (define WCB-SAP 1)
  96. (define WCB-SAR 2)
  97. (define WCB-SAC 4)
  98. (define WCB-FAC 8)
  99.  
  100. (define (WCB-SAP? wcb) (not (zero? (logand WCB-SAP wcb))))
  101. (define (WCB-SAR? wcb) (not (zero? (logand WCB-SAR wcb))))
  102. (define (WCB-SAC? wcb) (not (zero? (logand WCB-SAC wcb))))
  103. (define (WCB-FAC? wcb) (not (zero? (logand WCB-FAC wcb))))
  104.  
  105. (define END-OF-CHAIN -1)
  106. (define START-OF-CHAIN -2)
  107.  
  108. (define (FIELD-LEN blk pos)
  109.   (char->integer (string-ref blk pos)))
  110.  
  111. (define (SET-FIELD-LEN! blk pos len)
  112.   (string-set! blk pos (integer->char len)))
  113.  
  114. ;;; This is dangerous.  At the moment all occurences of next-field
  115. ;;; have simple expressions for the second argument.
  116.  
  117. (define (next-field blk pos)
  118.   (+ (FIELD-LEN blk pos) pos 1))
  119.  
  120. (define (NEXT-CNVPAIR blk pos)
  121.   (next-field blk (next-field blk (+ 1 pos))))
  122.  
  123. (define (LEAF? blk) (= (BLK-LEVEL blk) LEAF))
  124.  
  125. ;;; LCK and ENT tables
  126.  
  127. ;;; If you change this change amnesia-ent!
  128. ;;; This depends on seg never being less than -1
  129. (define (HASH2INT seg num)
  130.   (remainder (+ (* seg 97) num (* num-buks (+ 1 (quotient 97 num-buks))))
  131.          num-buks))
  132.  
  133. ;;; Called with SEG-LCK locked.
  134. ;;; If you don't know what you are doing. DON'T DO IT!
  135. ;;; Compute inverse hash function so that ent can still be found.
  136. (define (amnesia-ent! ent)
  137.   (ENT-SET-ID! ent (HASH2INT (+ 1 (ENT-SEG ent)) (ENT-ID ent)))
  138.   (ENT-SET-DTY! ent #f)            ;so block will not be written out when released.
  139.   (ENT-SET-PUS! ent 0)
  140.   (if (ENT-BLK ent) 
  141.       (if (BLK-TYP? (ENT-BLK ent) DIR-TYP)
  142.       (BLK-SET-TYP! (ENT-BLK ent) IND-TYP)))    ; avoid useless warnings or writes
  143.   (ENT-SET-SEG! ent -1)
  144.   (ENT-SET-AGE! ent 128))
  145.  
  146. (define (SAME-BUK? a-seg a-num b-seg b-num)
  147.   (= (HASH2INT a-seg a-num) (HASH2INT b-seg b-num)))
  148.  
  149. (define (GET-BUK seg blk-num)
  150.   (vector-ref buk-tab (HASH2INT seg blk-num)))
  151.  
  152. ;;; doesnt wait, ie, returns #F is busy
  153. (define (GET-BUK-LCK seg blk-num)
  154.   (try-lck (vector-ref lck-tab (HASH2INT seg blk-num))))
  155.  
  156. (define (GET-BUK-WAIT seg blk-num)
  157.   (lck! (vector-ref lck-tab (HASH2INT seg blk-num)))
  158.   (vector-ref buk-tab (HASH2INT seg blk-num)))
  159.  
  160. (define (REL-BUK! seg blk-num)
  161.   (unlck! (vector-ref lck-tab (HASH2INT seg blk-num))))
  162.  
  163. ;;; SET-BUK! assumes BUK is already lcked by caller
  164. (define (SET-BUK! seg blk-num ent)
  165.   (vector-set! buk-tab (HASH2INT seg blk-num) ent))
  166.  
  167. (define ACCREAD 'ACCREAD)
  168. (define ACCWRITE 'ACCWRITE)
  169. (define ACCPEND 'ACCPEND)
  170.  
  171. ;;;; Routines for finding the appropriate BLK for an operation.
  172. ;;; PACKETs used to return multiple values from chain-find.
  173. ;;; and various other operations
  174.  
  175. (define PKT-SIZE 6)
  176.  
  177. (define (MATCH-TYPE p) (vector-ref p 0)) ;see below for PASTP, QPASTP,...
  178. (define (MATCH-POS p) (vector-ref p 1))    ;position of key we (almost) matched.
  179. (define (KEY-POS p) (vector-ref p 2))    ;number of matching characters
  180. (define (PREV-MATCH-POS p) (vector-ref p 3))    ;position of PREVIOUS key we (almost) matched.
  181. (define (BLK-TO-CACHE p) (vector-ref p 4))    ;blk number to cache
  182. (define (SUCCESS-CODE p) (vector-ref p 5))    ;UNUSED
  183.  
  184. (define (SET-MATCH-TYPE! p v) (vector-set! p 0 v))
  185. (define (SET-MATCH-POS! p v) (vector-set! p 1 v))
  186. (define (SET-KEY-POS! p v) (vector-set! p 2 v))
  187. (define (SET-PREV-MATCH-POS! p v) (vector-set! p 3 v))    ;position of PREVIOUS key we (almost) matched.
  188. (define (SET-BLK-TO-CACHE! p v) (vector-set! p 4 v))    ;blk number to cache
  189. (define (SET-SUCCESS-CODE! p v) (vector-set! p 5 v))    ;UNUSED
  190.  
  191. (define (PACK! p type b-pos k-pos p-pos)
  192.   (SET-MATCH-TYPE! p type)
  193.   (SET-MATCH-POS! p b-pos)
  194.   (SET-KEY-POS! p k-pos)
  195.   (SET-PREV-MATCH-POS! p p-pos))
  196.  
  197. (define PASTP 'PASTP)    ;not exact match;repeat count of next key will change.
  198.             ;match(new-key, after-key) > repeatcount(after-key)
  199. (define QPASTP 'QPASTP)    ;not exact match;repeat count of next key will not change.
  200.             ;match(new-key, after-key) <= repeatcount(after-key)
  201. (define MATCH 'MATCH)            ;exact match (not split key).
  202. (define MATCHEND 'MATCHEND)        ;matched split key.
  203. (define PASTEND 'PASTEND)        ;greater than split key.
  204.  
  205. (define REM-SCAN -1)            ;operation codes for SCAN
  206. (define COUNT-SCAN 0)
  207. (define MODIFY-SCAN 1)
  208.  
  209. (define SKEY-COUNT MATCH-POS)        ;aliased function names for SCAN
  210. (define SET-SKEY-COUNT! SET-MATCH-POS!)
  211. (define SKEY-LEN KEY-POS)
  212. (define SET-SKEY-LEN! SET-KEY-POS!)
  213.  
  214. (define (SEG-PORT seg) (SEGD-PORT (vector-ref segd-tab seg)))
  215. (define (SEG-BSIZ seg) (SEGD-BSIZ (vector-ref segd-tab seg)))
  216. (define (SEG-USED seg) (SEGD-USED (vector-ref segd-tab seg)))
  217. (define (SEG-STR seg) (SEGD-STR (vector-ref segd-tab seg)))
  218. (define (SEG-RT-HAN seg) (SEGD-RT-HAN (vector-ref segd-tab seg)))
  219. (define (SEG-FL-HAN seg) (SEGD-FL-HAN (vector-ref segd-tab seg)))
  220. (define (SEG-LCK seg) (SEGD-LCK (vector-ref segd-tab seg)))
  221. (define (SEG-FCK seg) (SEGD-FCK (vector-ref segd-tab seg)))
  222. (define (SEG-FLC-LEN seg) (SEGD-FLC-LEN (vector-ref segd-tab seg)))
  223. (define (SEG-FLC seg) (SEGD-FLC (vector-ref segd-tab seg)))
  224.  
  225. (define (SEG-SET-PORT! seg port) (SEGD-SET-PORT! (vector-ref segd-tab seg) port))
  226. (define (SEG-SET-BSIZ! seg bsiz) (SEGD-SET-BSIZ! (vector-ref segd-tab seg) bsiz))
  227. (define (SEG-SET-USED! seg used) (SEGD-SET-USED! (vector-ref segd-tab seg) used))
  228. (define (SEG-SET-STR! seg str) (SEGD-SET-STR! (vector-ref segd-tab seg) str))
  229. (define (SEG-SET-FLC-LEN! seg flc-len) (SEGD-SET-FLC-LEN! (vector-ref segd-tab seg) flc-len))
  230. (define (SEG-SET-FLC! seg flc) (SEGD-SET-FLC! (vector-ref segd-tab seg) flc))
  231.